{-# LANGUAGE TemplateHaskell, TypeOperators, TypeFamilies,
  MultiParamTypeClasses #-}

{-# OPTIONS_GHC -fcontext-stack=250 #-}

module GenCnvExample where

import TypeBasics
import Yoko

import Convert



data Exp = Const Int | Plus Exp Exp

data Exp2 = Const2 Int (Maybe Exp2) | Plus2 Exp2 Exp2 deriving Show



data Cnv0 = Cnv0
type instance Cnv Cnv0 Exp = Exp2

instance Convert Cnv0 Exp where
  convert cnv e = case project (disband e) of
    Left  (Fds_Const i) -> Const2 i Nothing
    Right x             -> convertDCs cnv x



ex0 = convert Cnv0 (Plus (Const 3) (Const 4))





-- to be generated by yoko's TH
data Fds_Const = Fds_Const Int
data Fds_Plus  = Fds_Plus  Exp Exp
concat `fmap` mapM derive [''Fds_Const, ''Fds_Plus, ''Exp]
type instance Tag Fds_Const = TagConst   ;   data TagConst
type instance Tag Fds_Plus  = TagPlus    ;   data TagPlus
type instance Range Fds_Const = Exp
type instance Range Fds_Plus  = Exp
instance DC Fds_Const where rejoin (Fds_Const i)     = Const i
instance DC Fds_Plus  where rejoin (Fds_Plus  el er) = Plus  el er
type instance DCs Exp = N Fds_Const :+ N Fds_Plus
instance DT Exp where
  disband (Const i)     = DCsOf $ Le . N $ Fds_Const  i
  disband (Plus  el er) = DCsOf $ Ri . N $ Fds_Plus   el er
type instance Rep Fds_Const = F (D Int)
type instance Rep Fds_Plus  = F (R Exp) :* F (R Exp)
instance Generic Fds_Const where
  rep ~(Fds_Const i) = F $ D i
  obj ~(F (D i))     = Fds_Const i
instance Generic Fds_Plus where
  rep ~(Fds_Plus el er)       = F (R el) :* F (R er)
  obj ~(F (R el) :* F (R er)) = Fds_Plus el er

data Fds_Const2 = Fds_Const2 Int (Maybe Exp2)
data Fds_Plus2  = Fds_Plus2  Exp2 Exp2
concat `fmap` mapM derive [''Fds_Const2, ''Fds_Plus2, ''Exp2]
type instance Tag Fds_Const2 = TagConst2   ;   data TagConst2
type instance Tag Fds_Plus2  = TagPlus2    ;   data TagPlus2
type instance Range Fds_Const2 = Exp2
type instance Range Fds_Plus2  = Exp2
instance DC Fds_Const2 where rejoin (Fds_Const2 i me)     = Const2 i me
instance DC Fds_Plus2  where rejoin (Fds_Plus2  el er) = Plus2  el er
type instance DCs Exp2 = N Fds_Const2 :+ N Fds_Plus2
instance DT Exp2 where
  disband (Const2 i me)  = DCsOf $ Le . N $ Fds_Const2 i me
  disband (Plus2  el er) = DCsOf $ Ri . N $ Fds_Plus2  el er
type instance Rep Fds_Const2 = F (D Int) :* F (Maybe (R Exp2))
type instance Rep Fds_Plus2  = F (R Exp2) :* F (R Exp2)
instance Generic Fds_Const2 where
  rep ~(Fds_Const2 i me) = F (D i) :* F (fmap R me)
  obj ~(F (D i) :* F me)       = Fds_Const2 i (fmap unR me)
instance Generic Fds_Plus2 where
  rep ~(Fds_Plus2 el er) = F (R el) :* F (R er)
  obj ~(F (R el) :* F (R er)) = Fds_Plus2 el er





-- since we're just emulating IsPrefixOf for now, we must provide these
-- instances on an ad-hoc basis
type instance IsPrefixOf TagConst TagConst2 = True
type instance IsPrefixOf TagConst TagPlus2  = False
type instance IsPrefixOf TagPlus  TagConst2 = False
type instance IsPrefixOf TagPlus  TagPlus2  = True
